;;; -*- Syntax: Common-lisp; Package: PZ; Default-character-style: (:FIX :BOLD :NORMAL) -*-


;;; SOLVE is the main function - given a board, it sets up the problem for solution and then
;;; solves it.   The file "Puzzle:puzzle;Calling-dependencies.text" shows the way all of the
;;; subsidiary functions are reached.

(defun solve (board &key (show-interval 1000))
  (initialize-problem board)
  (showboard board)
  (do ()
      ((goalp *base-board*)
       (format t "~&~74t~'b⊂SOLVED!~⊃~&")
       (showboard *base-board*))
    (next-node *base-board* :show-interval show-interval)))

;;; INITIALIZE-PROBLEM resets all the statistical counters, clears the various memories
;;; inside the boards, discovers if the board is already partially solved.  It copies the
;;; problem onto the *base-board*.  Because of this copying, the problem state inside the
;;; board that is being solved is not touched - so that when, say, *easy-puzzle* is solved,
;;; its original state is unchanged and it can be solved again without re-evaluating the
;;; Defparameter statement that set it up.

(defun initialize-problem (board)
  (setq *nodes-considered* 0
	*rejections* 0
	*acceptances* 0)
  (clear-heuristic-statistics)
  (setf (board-moves board) nil)
  (setf (board-blank-origin board)(board-blank board))
  (evaluate-initial-position board)
  (check-goodness board)
  (setf *original-board* board)
  (copy-board-position *base-board* *original-board*)
  (copy-board-position *hidden-board* *original-board*)	; Notice partial solutions.
  (setf (fifo-queue-line *queue*)(list nil))
  )

;;; Each Node is a list of moves going back to the original position.  The Queue will never
;;; be empty.  When a move is accepted, the queue is flushed, but then the current position
;;; is added to the queue.  When the current position is the original position, the queue =
;;; '(nil).  The last number in the list is the current position of the blank.  (In the case
;;; of the NIL node, the original blank position is stored on the board.)  STORED-SUCCESSORS
;;; filters the move that undoes the last move.

;;; The Tforms are trace hooks.  When turned on, they print out information about each
;;; expanded node.  When turned off, they just emit a characteristic beep that allows a
;;; rough audio trace of the solution.

(defun next-node (BaseBoard &key (show-interval 1000))
  (let ((node (next *queue*)))
    (loop for child in (stored-successors node BaseBoard)
	  for thischild = (cons child node)
	  do (new-position-for-board
	       thischild *hidden-board*)
	     (incf *nodes-considered*)
	     (when (and show-interval
			(zerop (mod  *nodes-considered* show-interval)))
	       (showboard baseboard))
	     (cond ((may-reject (worse *hidden-board* BaseBoard)))
		   ;; Don't pursue a worse position
		   ((may-accept (better *hidden-board* BaseBoard) thischild baseboard)
		    ;; Don't even look at any remaining children if this one is better than the 
		    ;; BoardPosition.
		    (return nil))
		   (t (Tform  2000 10000 ".")
		      (add thischild *queue*)))
	     )))

(defun may-reject (reason)
  (when reason
    (Tform 4500 20000 "..rejected by ~a" reason)
    (incf *rejections*)
    (incf (get reason :success))
    reason))

(defun may-accept (reason thischild baseboard)
  (when reason
    (Tform 900 0 "~&Considering move ~s" thischild)
    (accept thischild Baseboard)
    (unless (equal (coerce (board-position baseboard) 'list)
		   (coerce (board-position *hidden-board*) 'list))
      (format t "Didn't correctly reset board.~&")
      (showboard baseboard)(showboard *hidden-board*)
      (error "Lose, Lose.."))
    (evaluate-intermediate-position BaseBoard)
    (Tform 900 30000 " ..accepted by ~a." reason)
    (incf *acceptances*)
    (incf (get reason :success))
    (flush *queue*)
    (add thischild *queue*)
    (when (and *acceptance-trace*
	       (yes-or-no-p "Show Board? "))
      (showboard baseboard))
    reason
    ))

;;; MOVE executes a single move, by interchanging the blank and a tile.  Remember the
;;; current contents of the square into which the board is moving.  Set that square blank.
;;; Write the old contents of that square into the square's old position.  Note the new
;;; position of the blank.  Notice that this is a pure interchange operation.  No check for
;;; the legality of the move is performed.  The caller has responsibility for adding the
;;; move to the boards MOVES list.

(defun move (singlemove board)
  (let ((current-contents (aref (board-position board) (1- singlemove))))	
    (setf (aref (board-position board) (1- singlemove))	
	  :blank)
    (setf (aref (board-position board) (1- (board-blank board)))
	  current-contents)
    (setf (board-blank board) singlemove)
    ))


;;; We repeatedly have the following situation: we have a list of moves: 
;;; (Final ....Intermediate .... Initial) such that if the moves were executed in reverse
;;; order on the initial board, it would go through the intermediate state to the final
;;; position.  But the board is already in the intermediate state, and its MOVES list is a
;;; pointer to the sublist (Intermediate .... Initial).   We only want to execute the moves
;;; from Final back to Intermediate, in reverse order.  We do this by passing 
;;; (Final ....Intermediate .... Initial) as the longlist, the MOVES list of the board as
;;; the shortlist, recursing down longlist til we find shortlist, and then executing the
;;; moves as we come back up the stack.

(defun make-intervening-moves (longlist shortlist board)
  (cond ((and (null longlist)
	      (or (board-moves board) shortlist))
	 (showboard board)
	 (error "Never found a common sublist in Make-Intervening-Moves."))
	((not (eq longlist shortlist))
	 (make-intervening-moves (cdr longlist)
				 shortlist board)
	 (move (first longlist) board)
	 (setf (board-moves board) longlist))
	(t nil)))


;;; COMMON-ROOT is for moving the hidden board from a position corresponding to one node to
;;; a postion corresponding to the next node on the queue.  We want to back the hidden board
;;; back up to an common ancestor of the two nodes Because we are making a depth-first
;;; search, we know that the length of the two descents can be off by at most one link.

(defun common-root (seq1 seq2)
  (cond ((or (null seq1)(null seq2))
	 nil)
	((eq seq1 seq2) seq1)
	((eq (cdr seq1) seq2) seq2)
	(t (common-root (cdr seq1)(cdr seq2)))))

;;; Make the initial evaluation of the board.  Notice if it is already partially solved.

(defun evaluate-initial-position (board)
  (completed-chain board)
  ;; Figure out in which row the chain terminates.
  (setf (board-last-complete-row board)
	(floor (board-completed-chain board) (board-side board))))

;;; Calculate the length of the completed chain of tiles.  This will NOT notice if the chain
;;; has, say, been completed up through tile 12, but has been rotated out of final position
;;; - it only counts the tiles currently in place.

(defun completed-chain (board)
  ;; Go through the board position square by sqare, finding out how many tiles 
  ;; are already in the completed chain.  Leave the loop when you reach the end.
  (setf (board-completed-chain board) 0)
  (loop for place from 1 to (board-size board)
	if (equal place (position-contents place board))	
	  ;; Have to use EQUAL rather than = cuz of :blank.
	  do (setf (board-completed-chain board) place)	
	else
	  return place				; Final return for solved board.
	finally (return place)))

;;; A node (which represents a board position and is represented by a
;;; list of moves) is tested on the hidden-board.  If it is BETTER than
;;; the baseboard, the move is ACCEPTed, and the base board is advanced
;;; to that position by executing all of them moves in the node that go
;;; beyond the moves that the board has already executed.

(defun accept (movelist baseboard)
  (make-intervening-moves
    movelist (board-moves  baseboard) baseboard))

;;; Right now, intermediate positions are evaluated just the same way as are intial
;;; positions.


(defun evaluate-intermediate-position (board)
  (evaluate-initial-position board))

;;; NEW-POSITION-FOR-BOARD moves the hiddenboard between a position from
;;; one node to the next.

(defun new-position-for-board (newpos hiddenboard)
  (let ((commonroot (common-root newpos (board-moves hiddenboard))))
    (back-board-up-to-position (board-moves hiddenboard)
			       commonroot hiddenboard)
    (make-intervening-moves
      newpos commonroot hiddenboard)))


;;; The *hidden-board* must be backed up to the common ancestor of the
;;; destination board and its current board

(defun back-board-up-to-position (movelist commonroot board)
  (unless (eq movelist commonroot)
    (move (previous-move movelist board)
	  board)
    (pop (board-moves board))
    (back-board-up-to-position
      (cdr movelist) commonroot board)))

;;; Normally, the move that generated a particular position is just the second move on the
;;; board's list.  However, after the first move we cannot tell what move generated the
;;; current position by looking at the movelist.  Instead, the info is stored on the
;;; BLANK-ORIGIN slot of the board.

(defun previous-move (movelist board)
  (or (second movelist)
      (board-blank-origin board)))